OPTIONAL forth-tools

Only Forth Definitions

\ Compiler extensions

: :macro
  : immediate postpone (s") [char] ; string
   postpone evaluate postpone ; ;
aka :macro macro:

: lastbody
   last @ name> >body ;

\ Stack extensions

: nips   0 do nip loop ;

: reverse
  1+ 1 max 1 ?do i 1- roll loop ;

\ Dictionary extensions

: w,
  here w! 2 allot ;

\ Memory access extensions

: 2h!   dup >r 2 + h! r> h! ;

{
: w@+ ( addr -- addr+2 n )
  dup w@ 2 u+ ;
}
icode w@+ ( addr -- a+2 n )
   PUSH(EBX)                        \ save addr on stack
   0 [EBX] EBX MOVZXW                \ read value from addr to tos
   2 # 0 [EBP] ADD                  \ increment address
   RET   END-CODE

: w!+ ( addr n -- addr+2 )
  over w! 2 + ;

aka w!+ h!+

icode h@+ ( addr -- a+2 n )
   PUSH(EBX)                        \ save addr on stack
   0 [EBX] EBX MOVSXW                \ read value from addr to tos
   2 # 0 [EBP] ADD                  \ increment address
   RET   END-CODE

icode 2h@
   ebx eax mov
   0 [eax] ebx movsxw
   push(ebx)
   2 [eax] ebx movsxw
   ret end-code

ICODE h+! ( n addr -- )
   0 [EBP] EAX MOV
   16bit: eax 0 [EBX] ADD
   4 [EBP] EBX MOV
   8 # EBP ADD
   RET   END-CODE

{
icode []
   ebx ecx mov
   ecx 2 # shl
   pop(ebx)
   eax ebx add
   ret end-code

:macro h[]  2* + ;

: 4h!
   locals| a h w y x |
   a x h!+ y h!+ w h!+ h h!+ drop ;
}

\ This - deprecated

{
0 value this
512 stack: this's
: [[   this this's push   to this ;
: ]]   this's pop to this ;
}

\ Math extensions

: m+!
  dup >r 2@ rot m+ r> 2! ;

: u+  swap >r + r> ;

\ works with negative n so long as it's not less than -range
: wrap  ( n u-start u-range -- n )
   >r swap over - r> swap over 2* + swap mod + ;

-? : $cd ( path& len -- )
   pad zplace pad SetCurrentDirectory 0= abort" invalid directory" ;

\ String extensions

aka s" " immediate

: tabs>spaces   2dup 0 do dup c@ 9 = if bl over c! then 1 + loop drop ;

: <>""  c@ ;

: c@+
   dup c@ 1 u+ ;

: string:   create 256 /allot ;
